home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / tmodem20.lqr / DIRECT.INC < prev    next >
Encoding:
Text File  |  1985-06-10  |  8.9 KB  |  270 lines
  1.  
  2.    type
  3.       Char80arr       = array [ 1..80 ] of Char;
  4.  
  5. (****************************************************************************)
  6. (*                         GET DEFAULT DRIVE LETTER                         *)
  7. (****************************************************************************)
  8.    function
  9.       default_drive : char;
  10.    var
  11.       regs          : registerset;
  12.    begin
  13.       regs.AX := $1900;
  14.       msdos( regs );
  15.       default_drive := chr(ord('A')+lo(regs.AX));
  16.    end;
  17.  
  18. (****************************************************************************)
  19. (*                          CHANGE DEFAULT DRIVE                            *)
  20. (****************************************************************************)
  21.    procedure
  22.       change_drive(dr : char);
  23.    var
  24.       regs            : registerset;
  25.    begin
  26.       regs.AX := $0E00;
  27.       regs.DX := ord(upcase(dr)) - ord('A');
  28.       msdos( regs );
  29.    end;
  30.  
  31. (****************************************************************************)
  32. (*                          DISK SPACE AVAILABLE                            *)
  33. (****************************************************************************)
  34.    function
  35.       diskspace(dr : char) : integer;
  36.    var
  37.       regs         : registerset;
  38.       r            : real;
  39.    begin
  40.       regs.AX := $3600;
  41.       regs.DX := 1 + ord(upcase(dr)) - ord('A');
  42.       msdos( regs );
  43.       r := ((regs.AX * regs.CX * 1.0) * regs.BX);
  44.       diskspace := round( r / 1024.0);
  45.    end;
  46.  
  47. (****************************************************************************)
  48. (*                           TIME SERVICE ROUTINES                          *)
  49. (****************************************************************************)
  50.    function
  51.       time       : string80;
  52.    var
  53.       reg        : registerset;
  54.       h,m,s,w    : string[10];
  55.       i          : integer;
  56.    begin
  57.       reg.AX := $2C00;
  58.       intr($21,reg);
  59.       str(hi(reg.CX):2,h);
  60.       str(lo(reg.CX):2,m);
  61.       str(hi(reg.DX):2,s);
  62.       w := h + ':' + m + ':' + s;
  63.       for i:=2 to 8 do if w[i]=' ' then w[i]:='0';
  64.       time:=w;
  65.    end;
  66.    function
  67.       delta_time(t1,t2 : string80) : string80;
  68.    var
  69.       h,m,s       : integer;
  70.       th,tm,ts,tw : string[10];
  71.    begin
  72.       h:=bval(copy(t2,1,3)) - bval(copy(t1,1,3));
  73.       m:=bval(copy(t2,4,3)) - bval(copy(t1,4,3));
  74.       s:=bval(copy(t2,7,3)) - bval(copy(t1,7,3));
  75.       if s<0 then begin
  76.          s:=s+60;
  77.          m:=m-1;
  78.       end;
  79.       if m<0 then begin
  80.          m:=m+60;
  81.          h:=h-1;
  82.       end;
  83.       if h<0 then h:=h+24;
  84.       str(h:2,th);
  85.       str(m:2,tm);
  86.       str(s:2,ts);
  87.       tw:=th+':'+tm+':'+ts;
  88.       for s:=2 to 8 do if tw[s]=' ' then tw[s]:='0';
  89.       delta_time := tw;
  90.    end;
  91.  
  92. (****************************************************************************)
  93. (*                          DISK DIRECTORY LISTER                           *)
  94. (****************************************************************************)
  95.    procedure
  96.       dir_list;
  97.  
  98.    {$I-}
  99.  
  100.    var
  101.       DTA          : array [ 1..43 ] of Byte;
  102.       DTAseg,
  103.       DTAofs,
  104.       SetDTAseg,
  105.       SetDTAofs,
  106.       Error,
  107.       I, J,
  108.       Option       : Integer;
  109.       Regs         : registerset;
  110.       Buffer,
  111.       NamR         : String80;
  112.       curdir       : string80;
  113.       dn           : integer;
  114.       ch           : char;
  115.       Mask         : Char80arr;
  116.       horz_tab     : byte;
  117.  
  118. (****************************************************************************)
  119. (*  SetDTA resets the current DTA to the new address specified in the       *)
  120. (*  parameters 'SEGMENT' and 'OFFSET'.                                      *)
  121. (****************************************************************************)
  122.       procedure
  123.          SetDTA( Segment, Offset : Integer; var Error : Integer );
  124.       begin
  125.          Regs.AX := $1A00;
  126.          Regs.DS := Segment;
  127.          Regs.DX := Offset;
  128.          MSDos( Regs );
  129.          Error := Regs.AX and $FF;
  130.       end;
  131.  
  132. (****************************************************************************)
  133. (*  GetCurrentDTA is used to get the current Disk Transfer Area ( DTA )     *)
  134. (*  address.  A function code of $2F is stored in the high Byte of the AX   *)
  135. (*  register and a call to the predefined procedure MSDos is made.  This    *)
  136. (*  can also be accomplished by using the "Intr" procedure with the same    *)
  137. (*  register record and a $21 specification for the interrupt.              *)
  138. (****************************************************************************)
  139.       procedure
  140.           GetCurrentDTA( var Segment, Offset : Integer;
  141.                          var Error : Integer );
  142.       begin
  143.          Regs.AX := $2F00;
  144.          MSDos( Regs );
  145.          Segment := Regs.ES;
  146.          Offset := Regs.BX;
  147.          Error := Regs.AX and $FF;
  148.       end;
  149.  
  150. (****************************************************************************)
  151. (*  GetFirst gets the first directory entry of a particular file Mask.  The *)
  152. (*  Mask is passed as a parameter 'Mask'.                                   *)
  153. (****************************************************************************)
  154.       procedure
  155.          GetFirst( Mask : Char80arr; var NamR : String80;
  156.                    Segment, Offset : Integer; Option : Integer;
  157.                    var Error : Integer );
  158.       var
  159.          I : Integer;
  160.       begin
  161.          Error := 0;
  162.          Regs.AX := $4E00;
  163.          Regs.DS := Seg( Mask );
  164.          Regs.DX := Ofs( Mask );
  165.          Regs.CX := Option;
  166.          MSDos( Regs );
  167.          Error := Regs.AX and $FF;
  168.          I := 1;
  169.          repeat
  170.             NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] );
  171.             I := I + 1;
  172.          until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
  173.          NamR[ 0 ] := Chr( I - 1 );
  174.       end;
  175.  
  176. (****************************************************************************)
  177. (*  GetNextEntry uses the first bytes of the DTA for the file Mask, and     *)
  178. (*  returns the next file entry on disk corresponding to the file Mask.     *)
  179. (****************************************************************************)
  180.       procedure
  181.          GetNextEntry( var NamR : String80; Segment, Offset : Integer;
  182.                        Option : Integer; var Error : Integer );
  183.       var
  184.          I : Integer;
  185.       begin
  186.          Error := 0;
  187.          Regs.AX := $4F00;
  188.          Regs.CX := Option;
  189.          MSDos( Regs );
  190.          Error := Regs.AX and $FF;
  191.          I := 1;
  192.          repeat
  193.             NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] );
  194.             I := I + 1;
  195.          until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
  196.          NamR[ 0 ] := Chr( I - 1 );
  197.       end;
  198.  
  199. (****************************************************************************)
  200. (*                        LIST DIRECTORY OF DISK                            *)
  201. (****************************************************************************)
  202.    begin
  203.       mkwin(1,1,80,24,'Disk Directory');
  204.       horz_tab := 4;
  205.       for I := 1 to 21 do DTA[ I ] := 0;
  206.       for I := 1 to 80 do begin
  207.          Mask[ I ] := Chr( 0 );
  208.          NamR[ I ] := Chr( 0 );
  209.       end;
  210.       NamR[ 0 ] := Chr( 0 );
  211.       GetCurrentDTA( DTAseg, DTAofs, Error );
  212.       if ( Error <> 0 ) then begin
  213.          WriteLn( 'Unable to get current DTA' );
  214.          WriteLn( 'Program aborting.' );
  215.          Halt;
  216.       end;
  217.       SetDTAseg := Seg( DTA );
  218.       SetDTAofs := Ofs( DTA );
  219.       SetDTA( SetDTAseg, SetDTAofs, Error );
  220.       if ( Error <> 0 ) then begin
  221.          WriteLn( 'Cannot reset DTA' );
  222.          WriteLn( 'Program aborting.' );
  223.          Halt;
  224.       end;
  225.       Error := 0;
  226.       Buffer[ 0 ] := Chr( 0 );
  227.       Option:=16;
  228.       ch:=default_drive;
  229.       dn:=ord(ch)-ord('A')+1;
  230.       getdir(dn,curdir);
  231.       writeln('   Current Drive\Directory: ',curdir);
  232.       Write('                  Dir Mask: ' );
  233.       ReadLn( Buffer );
  234.       WriteLn;
  235.       if ( length( Buffer ) = 0 ) then
  236.          Buffer := '*.*';
  237.       for I := 1 to length( Buffer ) do
  238.          Mask[ I ] := Buffer[ I ];
  239.       GetFirst( Mask, NamR, SetDTAseg, SetDTAofs, Option, Error );
  240.       if ( Error = 0 ) then begin
  241.          gotoxy(horz_tab,wherey);
  242.          Write( NamR );
  243.          horz_tab := horz_tab + 15;
  244.       end
  245.       else
  246.          WriteLn( '   File ''', Buffer, ''' not found.' );
  247.       while ( Error = 0 ) do begin
  248.          GetNextEntry( NamR, SetDTAseg, SetDTAofs, Option, Error );
  249.          if ( Error = 0 ) then begin
  250.             gotoxy(horz_tab,wherey);
  251.             Write( NamR );
  252.             horz_tab := horz_tab + 15;
  253.             if horz_tab > 70 then begin
  254.                horz_tab := 4;
  255.                writeln;
  256.             end;
  257.          end;
  258.       end;
  259.       SetDTA( DTAseg, DTAofs, Error );
  260.       if horz_tab > 4 then
  261.          writeln;
  262.       writeln;
  263.       writeln('   Bytes Available: ',diskspace(ch),'k');
  264.       write('  ');
  265.       wait_for_key;
  266.       rmwin;
  267.    end;
  268.  
  269.    {$I+}
  270.